home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / JARexx / ARexxTools.f < prev    next >
Encoding:
FORTH Source  |  1993-06-11  |  11.6 KB  |  551 lines
  1.  
  2. \ JForth specific ARexx Tools
  3. \
  4. \ Author: Phil Burk
  5. \ Based on a design by Martin Kees, Mike Haas and Phil Burk
  6. \ Copyright 1991 Phil Burk, Martin Kees, Mike Haas
  7. \
  8. \ 00001 PLB 1/21/92 Added DUP and SWAP to ERR.#>$ for default.
  9. \ 00002 PLB 1/28/92 Save RX-SAVE-MSG, Check stack depth in RX.EXEC.LINE
  10. \ 00003 PLB/Kees 4/23/92 Add R to parsing format.
  11. \ 00004 MDH/PLB 4/27/92 Open RexxSysLib in RX.TERM
  12. \ 00005 mdh 6/10/93  RX.GET.MSG must clear RX-RESULT1 & RX-RESULT2
  13.  
  14. getmodule includes
  15. getmodule arexxmod
  16.  
  17. include? CreatePort() ju:exec_support
  18. include? tolower ju:char-macros
  19. include? { ju:locals
  20. include? task-error_codes ju:error_codes
  21. include? task-arexxcalls.f jrx:ARexxCalls.f
  22.  
  23. ANEW TASK-ARexxTools.F
  24.  
  25. \ Define errors
  26. RXERR_BASE
  27. ERR: RXERR_ILLEGAL_PARAMETER
  28. ERR: RXERR_ILLEGAL_COMMAND
  29. ERR: RXERR_NOT_INITIALIZED
  30. ERR: RXERR_NO_LIBRARY
  31. ERR: RXERR_NAME_IN_USE
  32. drop
  33.  
  34. : ERR.#>$ ( error_code -- $message )
  35.     CASE
  36.         RXERR_ILLEGAL_PARAMETER OF " Illegal ARexx parameter!" ENDOF
  37.         RXERR_ILLEGAL_COMMAND OF " Illegal ARexx command!" ENDOF
  38.         RXERR_NOT_INITIALIZED OF " RX.INIT not called!" ENDOF
  39.         RXERR_NO_LIBRARY OF " No ARexx library!" ENDOF
  40.         RXERR_NAME_IN_USE OF " ARexx Port name already in use!" ENDOF
  41.         dup err.#>$ swap \ 00001
  42.     ENDCASE
  43. ;
  44.  
  45. variable RX-PORT-PTR  \ Our port for receiving commands
  46. variable RX-MESSAGE-PTR \ rexxmsg for sending commands
  47. variable RX-QUIT    \ set TRUE to stop scanning
  48. variable RX-DATA    \ for use from outside
  49. variable RX-RESULT1 \ corresponds to result fields in RexxMsg
  50. variable RX-RESULT2
  51. variable RX-ERROR
  52. variable RX-SAVE-MSG  \ save in case of abort 00002
  53.  
  54. \ This is used internally by REXXCLUDE and RXUnderKey
  55. defer RX.AFTER.INTERPRET   ' noop is RX.AFTER.INTERPRET
  56.  
  57. : RX.GET.MSG ( -- rexxmsg | 0 )
  58.     rx-port-ptr @ GetMsg()
  59.     dup rx-save-msg ! \ 00002
  60.     rx-result2 off  \ 00005
  61.     rx-result1 off  \ 00005
  62. ;
  63.  
  64. : RX.WAIT.MSG ( -- rexxmsg )
  65.     rx-port-ptr @ WaitPort() drop
  66.     rx.get.msg
  67. ;
  68.  
  69. : RX.ARG[]  ( n rexxmsg -- arg-addr , index into argument array )
  70.     .. rm_args
  71.     swap cells +
  72. ;
  73.  
  74. : RX.PARSE.NUM ( 0string -- num 0scan true | false )
  75. { 0str | &token 0scan cnt quote result -- 0scan num true | false }
  76.     0 -> result
  77. \ parse out number
  78.     0str StcToken() -> quote -> cnt -> 0scan -> &token
  79. \
  80. \ don't try with quoted strings
  81.     quote 0=
  82.     IF
  83.         cnt here c!
  84.         &token here 1+ cnt cmove
  85.         here number?
  86.         IF
  87.             drop 0scan
  88.             true -> result
  89.         THEN
  90.     THEN
  91.     result
  92. ;
  93.  
  94. : RX.PARSE.STRING ( $format 0string -- ...params... 0left true | false )
  95. { $format 0str | &token cnt quote #params result &format #added -- ....... }
  96. \ Parse input string based on formatted string containing "NNSSN"
  97. \ For N , return NUM
  98. \ For S , return ADDR COUNT
  99.     true -> result
  100.     0 -> #added
  101.     $format count -> #params -> &format
  102.     #params 0
  103.     DO
  104.         &format i + c@ toupper \ what is next parameter
  105.         CASE
  106. \ get number
  107.             ascii N
  108.             OF
  109.                 0str rx.parse.num
  110.                 IF ( -- num 0str )
  111.                     -> 0str
  112.                     1 +-> #added
  113.                 ELSE
  114.                     ." RX.PARSE.STRING - Bad Number!" cr
  115.                     #added xdrop
  116.                     false -> result
  117.                     LEAVE
  118.                 THEN
  119.             ENDOF
  120. \
  121. \ get string
  122.             ascii S
  123.             OF
  124.                 0str StcToken() -> quote -> cnt -> 0str -> &token
  125.                 cnt
  126.                 IF
  127.                     quote
  128.                     IF
  129.                         &token 1+ cnt 1-  \ remove ' or "
  130.                     ELSE
  131.                         &token cnt
  132.                     THEN
  133.                     2 +-> #added
  134.                 ELSE
  135.                     ." RX.PARSE.STRING - Bad String" cr
  136.                     #added xdrop
  137.                     false -> result
  138.                     LEAVE
  139.                 THEN
  140.             ENDOF
  141. \
  142. \ get Remainder of line as string (by Marty Kees) 00003
  143.             ascii R
  144.             OF
  145.                 i #params 1- = NOT
  146.                 IF
  147.                     ." RX.PARSE.STRING - R must be last format!" cr
  148.                 THEN
  149.                 0str StcToken() -> quote -> cnt -> 0str -> &token
  150.                 cnt
  151.                 IF quote
  152.                    IF &token 1+ cnt 1-  \ remove ' or "
  153.                    ELSE
  154.                       &token 0COUNT  \ GET REST OF LINE
  155.                    THEN
  156.                    2 +-> #added
  157.                 ELSE
  158.                     ." RX.PARSE.STRING - Bad String" cr
  159.                     #added xdrop
  160.                     false -> result
  161.                     LEAVE
  162.                 THEN
  163.             ENDOF
  164. \
  165.             ." Invalid format = " emit cr
  166.             #added xdrop
  167.             false -> result
  168.             LEAVE
  169.         ENDCASE
  170.     LOOP
  171. \
  172.     result
  173.     IF
  174.         0str true
  175.     ELSE
  176.         false
  177.     THEN
  178. ;
  179.  
  180. :STRUCT  RX_COMMAND
  181.     rptr  rxc_name    \ command name, eg. " DRAWXYTEXT"
  182.     rptr  rxc_format  \ parameter format, eg. " NNS"
  183.     rptr  rxc_cfa
  184. ;STRUCT
  185.  
  186. variable RX-NUM-COMMANDS
  187. variable RX-MAX-COMMANDS
  188. variable RX-COMMAND-TABLE
  189. variable ""  \ empty string, keep zero
  190.  
  191. : RX.FREE.CTABLE ( -- , free allocated table )
  192.     rx-command-table freevar
  193.     rx-num-commands off
  194.     rx-max-commands off
  195. ;
  196.  
  197. if.forgotten rx.free.ctable
  198.  
  199. : RX.COMMAND[] ( n -- &command )
  200.     dup rx-max-commands @ >= abort" RX.COMMAND[] - index too large!"
  201.     sizeof() rx_command *
  202.     rx-command-table @ +
  203. ;
  204.  
  205. : RX.ADD.COMMAND ( $name $format cfa -- )
  206.     rx-num-commands @ rx.command[] >r
  207.     r@ s! rxc_cfa
  208.     r@ s! rxc_format
  209.     r@ s! rxc_name
  210.     rdrop
  211.     1 rx-num-commands +!
  212. ;
  213.  
  214. : RX.ALLOC.CTABLE ( n -- table | 0 , allocate table for commands )
  215.     rx.free.ctable
  216.     memf_clear swap
  217.     dup rx-max-commands !
  218.     sizeof() rx_command * allocblock
  219.     dup rx-command-table !
  220.     dup
  221.     IF
  222. \ initialize table to noops
  223.         rx-max-commands @ 0
  224.         DO
  225.             " NOOP" "" 'c noop rx.add.command
  226.         LOOP
  227.         0 rx-num-commands !
  228.     ELSE
  229.         0 rx-max-commands !
  230.     THEN
  231. ;
  232.                  
  233. : RX.KILL.SCRIPT ( rexxmsg -- , send CTRL-C to rexx script )
  234.     dup s@ mn_replyport
  235.     dup ..@ mp_flags 0=
  236.     IF ..@ mp_SigTask sigbreakf_ctrl_c
  237.         callvoid exec_lib signal
  238.     ELSE drop   
  239.     THEN
  240. ;
  241.  
  242. : RX.FIND.COMMAND { addr cnt | comm -- index true | false }
  243. \ look for matching command in table
  244.     0 \ default result
  245.     rx-num-commands @ 0
  246.     DO
  247.         i rx.command[] s@ rxc_name -> comm
  248.         comm c@ cnt =
  249.         IF
  250.             addr cnt comm 1+ text=?
  251.             IF
  252.                 drop i true
  253.                 LEAVE
  254.             THEN
  255.         THEN
  256.     LOOP
  257. ;
  258.  
  259. : RX.EXEC.LINE { 0arg | indx stdepth -- error? }
  260.     depth -> stdepth \ 00002
  261.     rx-error off
  262. \ parse out command
  263.     0arg StcToken() ( -- token scan len quote )
  264.     drop \ don't need quote
  265. \
  266. \ look for command in command list
  267.     swap >r ( -- token len ) rx.find.command
  268.     IF
  269.         -> indx
  270.         indx rx.command[] s@ rxc_format
  271.         r@ rx.parse.string
  272.         IF
  273.             drop \ don't need string
  274.             indx rx.command[] s@ rxc_cfa execute
  275.             rx-error @
  276.         ELSE
  277.             RXERR_ILLEGAL_PARAMETER
  278.         THEN
  279.     ELSE
  280.         RXERR_ILLEGAL_COMMAND
  281.     THEN
  282.     rdrop
  283. \
  284. \ There should now be just one more item on stack than
  285. \ when we started.  If not, abort! Otherwise we would crash
  286. \ horribly.  This would be a programming error! 00002
  287.     depth 1- stdepth = not
  288.     abort" RX.EXEC.LINE - stack depth error in command!"
  289. ;
  290.  
  291. : RX.EXEC.MSG ( rexxmsg -- )
  292. \ The first arg is an absolute pointer to a NULL terminated string.
  293.     0 swap rx.arg[] @ if>rel ?dup
  294.     IF
  295.         rx.exec.line ?dup
  296.         IF
  297. \ set error return if error in processing command
  298.             rx-result1 !
  299.         THEN
  300.     THEN
  301. ;            
  302.  
  303. : RX.REPLY.MSG ( rexxmsg -- )
  304.     >r
  305. \ do we have an argstring result?
  306.     rx-result2 @
  307.     IF
  308. \ did caller request result and no error?
  309.         r@ s@ rm_action rxff_result AND \ test bit
  310.         rx-result1 @ 0= AND
  311.         IF
  312. \ ." Result2 = " rx-result2 @ 0count type cr
  313.             rx-result2 @ >abs r@ ..!  rm_result2
  314.         ELSE
  315.             rx-result2 @ DeleteArgString() \ don't send it
  316.             0 r@ s!  rm_result2
  317.         THEN
  318.     ELSE
  319.         0 r@ s!  rm_result2
  320.     THEN
  321.     rx-result1 @ r@ s!  rm_result1
  322.     r> ReplyMsg()
  323.     rx-result1 off
  324.     rx-result2 off
  325. ;
  326.  
  327. : RX.SLAVE ( -- , process ARexx commands until RX-QUIT on )
  328.     rx-quit off
  329.        BEGIN
  330.            rx.wait.msg  ?dup
  331.            dup rx.exec.msg
  332.            rx.reply.msg
  333.         rx-quit @
  334.        UNTIL
  335. ;
  336.  
  337. : RX.SLAVE.SAFE ( -- )
  338.     >newline ." Waiting for commands from ARexx!" cr
  339.     rx-quit off
  340.     BEGIN
  341.         20,000 ?terminal.delay  \ wait 1/50 second between commands
  342.         rx-quit @ OR not
  343.     WHILE
  344.         BEGIN
  345.             rx.get.msg  ?dup
  346.             IF
  347.                 dup rx.exec.msg
  348.                 rx.reply.msg false
  349.             ELSE
  350.                 true
  351.             THEN
  352.             rx-quit @ or
  353.         UNTIL
  354.     REPEAT
  355. ;
  356.  
  357. \ =============== words to send messages to another port...
  358. \ We must Forbid so that the port doesn't disappear
  359. \ between FindPort() and PutMsg()
  360. 0 .IF
  361. /* example from 'FindPort()' entry in 1.3 'exec.doc' */
  362.     #include "exec/types.h"
  363.     struct MsgPort *FindPort();
  364.     
  365.     ULONG SafePutToPort(message, portname)
  366.     struct Message *message;
  367.     char           *portname;
  368.     {
  369.     struct MsgPort *port;
  370.     
  371.         Forbid();
  372.         port = FindPort(portname);
  373.         if (port)
  374.             PutMsg(port,message);
  375.         Permit();
  376.         return((ULONG)port); /* If zero, the port has gone away */
  377.     }
  378. .THEN
  379.  
  380. \ the JFORTH equivalent...
  381.  
  382. : SafePutToPort()    ( msg 0portname -- ok? )
  383.   Forbid()           ( -- msg portname )
  384.   FindPort() dup>r   ( -- msg port? )
  385.   IF
  386.      r@ swap         ( -- port msg )
  387.      PutMsg()        ( -- )
  388.   ELSE
  389.      drop            ( -- )
  390.   THEN
  391.   Permit()  r>       ( -- flag )   \ If zero, the port has gone away
  392. ;
  393.  
  394. : RX.PUT.MSG  ( 0arg 0portname -- error? , send message to ARexx port)
  395. \ >newline ." In RX.PUT.MSG" cr
  396. \ sets RX-RESULT1 and RX-RESULT2
  397. { 0arg 0portname | rmptr result -- error? }
  398.     true -> result \ default is error
  399.     rx-result1 off
  400.     rx-result2 off
  401. \
  402. \ are we initialized
  403.     rx-message-ptr @ ?dup
  404.     IF
  405.         -> rmptr
  406. \ set argument and flags
  407.         0arg if>abs 0 rmptr rx.arg[] !
  408. \
  409. \ convert our simple 0string to ARexx ArgString
  410.         rmptr 1 0 FillRexxmsg()
  411.         IF
  412.             rmptr 0portname SafePutToPort()
  413.             IF
  414. \ wait for this specific reply
  415.                 BEGIN
  416.                     rx.wait.msg dup rmptr =
  417.                     IF drop true
  418.                     ELSE
  419. \ process messages from macro
  420.                         dup rx.exec.msg
  421.                         rx.reply.msg
  422.                         false
  423.                     THEN
  424.                 UNTIL
  425.                 false -> result
  426.             THEN
  427.         ELSE
  428.             ." RX.PUT.MSG - could not FillRexxMsg!" cr
  429.         THEN
  430. \
  431. \ handle results
  432.         rmptr ..@ rm_result1 dup rx-result1 ! 0=
  433.         IF
  434. \ copy Result2 to HERE if so we can DeleteArgString
  435.             rmptr ..@ rm_result2 if>rel ?dup
  436.             IF
  437.                 dup 0count dup>r here 1+ swap move r> here c!
  438.                 DeleteArgString()
  439.                 here rx-result2 !
  440.             THEN
  441.         THEN
  442.         rmptr 1 clearRexxmsg()
  443.     ELSE
  444.         RXERR_NOT_INITIALIZED -> result
  445.       THEN
  446.       result
  447. \ >newline ." Out RX.PUT.MSG" cr
  448. ;
  449.  
  450. : RX.PUT.ACTION ( action -- , set in rx-message-ptr )
  451.     rx-message-ptr @ ?dup
  452.     IF
  453.         s! rm_action
  454.     ELSE
  455.         drop
  456.     THEN
  457. ;
  458.  
  459. : RX.PUT.TEXTRA ( 0arg -- error? , send message to resident Textra )
  460. \ >newline ." In RX.PUT.TEXTRA" cr
  461.     rxcomm rxff_result | rxff_string | rx.put.action
  462.     0" TEXTRA" rx.put.msg
  463.     rxcomm rx.put.action
  464. \ >newline ." Out RX.PUT.TEXTRA" cr
  465. ;
  466.  
  467. : RX.PUT.REXX ( 0arg -- error? , send message to resident process REXX )
  468.     0" REXX" rx.put.msg
  469. ;
  470.  
  471. : RX.FLUSH.MESSAGES ( -- #msgs , flush all pending messages from ARexx )
  472.     0
  473.     BEGIN
  474.         rx.get.msg ?dup
  475.     WHILE
  476.         10 rx-result1 !
  477.         rx.reply.msg \ return error=10 for unprocessed messages
  478.         1+
  479.     REPEAT
  480. ;
  481.     
  482. : RX.TERM  ( -- , terminate if initialized )
  483.     RexxSysLib?        \ 00004
  484.     rx-port-ptr @  \ check so we don't do this twice by accident, boom!
  485.     IF
  486.         rx.flush.messages ?dup
  487.         IF
  488.             . ." ARexx messages unprocessed." cr
  489.         THEN
  490.         rx-port-ptr @  DeletePort()
  491.         rx-port-ptr off
  492.     THEN
  493. \
  494.     rx-message-ptr @ ?dup
  495.     IF
  496.         DeleteRexxmsg()
  497.         rx-message-ptr off
  498.     THEN
  499.     -RexxSysLib
  500. ;
  501.  
  502. : RX.INIT  { 0hostname | result -- error? }
  503.     rx.term
  504. \
  505.     true -> result \ default error return
  506.     rx-port-ptr @ 0=  \ are we already initialized?
  507. \ Open Library
  508.     IF  lib_quit off \ don't abort if can't open
  509.         RexxSysLib?
  510.         
  511.         RexxSysLib_lib @ 0=
  512.         IF
  513.             RXERR_NO_LIBRARY -> result
  514.         ELSE
  515. \
  516. \ check to see if that name is in use
  517.             0hostname FindPort()
  518.             IF
  519.                 RXERR_NAME_IN_USE -> result
  520.             ELSE
  521. \ Initialize our message port for return calls.
  522.                 0hostname 0 CreatePort() ?dup
  523.                 IF  rx-port-ptr !
  524. \
  525. \ allocate a message port for use in calling macros
  526.                     rx-port-ptr @  0" rexx"  0hostname
  527.                     createRexxMsg() ?dup
  528.                     IF
  529.                         rx-message-ptr !
  530.                         rxcomm rx.put.action
  531.                         false -> result \ everything worked!!
  532.                     ELSE
  533.                         ERR_INSUFFICIENT_MEMORY -> result
  534.                     THEN
  535.                 ELSE
  536.                     ERR_INSUFFICIENT_MEMORY -> result
  537.                 THEN
  538.             THEN
  539.         THEN
  540.     THEN
  541.     result
  542. ;
  543.  
  544. : JFORTH_NAME    0" JFORTH"  ;
  545.  
  546. : RX.JFORTH.INIT ( -- error? , initialize port as "JFORTH" )
  547.     JFORTH_NAME rx.init
  548. ;
  549.  
  550. if.forgotten rx.term
  551.